home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue36 / construc / DRBOBEML.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-06-30  |  3.0 KB  |  111 lines
  1. unit DrBobEml;
  2. interface
  3. uses
  4.   Classes, ScktComp;
  5.  
  6. type
  7.   TBSMTP = class(TComponent)
  8.   public
  9.     constructor Create(AOwner: TComponent); override;
  10.     destructor Destroy; override;
  11.   public
  12.     procedure SendMail;
  13.   protected
  14.     _Socket: TClientSocket;
  15.     Step: Integer;
  16.     procedure SocketRead(Sender: TObject; Socket: TCustomWinSocket);
  17.     procedure SocketWrite(Sender: TObject; Socket: TCustomWinSocket);
  18.   private
  19.     fMailServer: String;
  20.     fMessageTo: String; { only one "To" at a time }
  21.     fMessageFrom: String;
  22.     fMessageSubject: String;
  23.     fMessageText: TStringList; { assign to TMemo.Lines for example }
  24.     procedure SetMessageText(NewText: TStringList);
  25.   published
  26.     property MailServer: String read fMailServer write fMailServer;
  27.     property MessageTo: String read fMessageTo write fMessageTo;
  28.     property MessageFrom: String read fMessageFrom write fMessageFrom;
  29.     property MessageSubject: String read fMessageSubject write fMessageSubject;
  30.     property MessageText: TStringList read fMessageText write SetMessageText;
  31.   end;
  32.  
  33. implementation
  34. uses
  35.   SysUtils, Forms; { for the Application.ProcessMessages-loop }
  36.  
  37. constructor TBSMTP.Create(AOwner: TComponent);
  38. begin
  39.   inherited Create(AOwner);
  40.   _Socket := TClientSocket.Create(Self);
  41.   _Socket.Port := 25; // according to RFC 821
  42.   _Socket.OnRead := SocketRead;
  43.   _Socket.OnWrite := SocketWrite;
  44.   Step := 0;
  45.   fMessageText := TStringList.Create
  46. end {Create};
  47.  
  48. destructor TBSMTP.Destroy;
  49. begin
  50.   fMessageText.Free;
  51.   _Socket.Free;
  52.   _Socket := nil;
  53.   inherited Destroy
  54. end {Destroy};
  55.  
  56. procedure TBSMTP.SetMessageText(NewText: TStringList);
  57. begin
  58.   fMessageText.Assign(NewText)
  59. end {SetMessageText};
  60.  
  61. procedure TBSMTP.SocketRead(Sender: TObject; Socket: TCustomWinSocket);
  62. var
  63.   Status: String;
  64. begin
  65.   Status := Socket.ReceiveText;
  66.   SocketWrite(Sender, Socket)
  67. end {SocketRead};
  68.  
  69. procedure TBSMTP.SocketWrite(Sender: TObject; Socket: TCustomWinSocket);
  70. const
  71.   CRLF = #13#10;
  72. var
  73.   i: Integer;
  74.   Send: String;
  75. begin
  76.   Inc(Step);
  77.   case Step of
  78.     1: Send := 'HELO ' + fMessageFrom;
  79.     2: Send := 'MAIL FROM:' + fMessageFrom;
  80.     3: Send := 'RCPT TO:' + fMessageTo; { captain }
  81.     4: Send := 'DATA';
  82.     5: begin
  83.          Socket.SendText('From: ' + fMessageFrom + CRLF);
  84.          Socket.SendText('To: ' + fMessageTo + CRLF);
  85.          Socket.SendText('Subject: ' + fMessageSubject + CRLF + CRLF);
  86.          for i:=0 to Pred(fMessageText.Count) do
  87.          begin
  88.            Send := fMessageText[i];
  89.            Socket.SendText(Send + CRLF)
  90.          end;
  91.          Send := '.'
  92.        end;
  93.     6: Send := 'QUIT'
  94.   end;
  95.   Socket.SendText(Send + CRLF)
  96. end {SocketWrite};
  97.  
  98. procedure TBSMTP.SendMail;
  99. begin
  100.   Step := 0;
  101.   _Socket.Active := False;
  102.   _Socket.Host := fMailServer;
  103.   _Socket.Open;
  104.   repeat
  105.   { need to rewrite this using low-level Windows APIs }
  106.     Application.ProcessMessages
  107.   until Step > 6 { QUIT }
  108. end {SendMail};
  109.  
  110. end.
  111.